|
参考文章，下面的代码全部是基于参考网址修改得到的，非常感谢原作者
背景
朋友每天在人工出报告上需要耗费很多时间，有3个文件，一个是需要出报告用户的基本信息excel文件user.xlst，另外一个是用户的检测记录excel文件data.xlsx，生成word报告模板template.docx
说明：下面很多内容是模拟的，但是和原报告基本相似，脚本文件理论上是可以运行的，我当前电脑是mac无法运行
准备报告模板文件template.docx
准备检测记录文件data.xlsx
 一个用户会有多条检测记录，取第一条检测记录的编号做为报告的编号，上面的数据按照固定格式放在第一个Sheet下面
准备用户名单user.xlsx
 性别是根据身份证号码的第17位判断的，偶数为女，奇数为男
制作宏文件"报告工具.xlsm"
模板制作记录
参考顶部的链接中创建一个按钮，名字修改为：cmd_makedoc，标题修改为：生成报告修改vba代码， 开发工具–》 查看代码，如果开发工具没有显示出来，请参考来调整， 程序上面的变量定义建议写出来加快程序速度代码如下
Private Sub cmd_makedoc_Click()
On Error GoTo Err_cmdExportToWord_Click
Dim objApp As Object 'Word.Application
Dim objDoc As Object 'Word.Document
Dim objDocOrigin As Object 'Word.Document
Dim xlApp As Excel.Application
Dim xlBook As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim strTemplates As String '模板文件路径名
Dim strFileName As String '将数据导出到此文件
Dim strData As String 'excel数据文件路径名
Dim i As Integer '用来循环遍历，选中姓名的起始行号
Dim j As Integer '用来循环遍历，选中区域的总行数
Dim k As Integer '用来循环遍历，选择区域遍历的行号
Dim m As Integer '用来循环遍历
Dim h As Integer '用来循环遍历
Dim l As Integer '用来循环遍历
Dim userName As String '定义变量，姓名
Dim sex As String '定义变量性别
Dim idno As String '定义变量身份证号码
Dim sampleNo As String '定义变量编号
Dim takeTime(4) As String '定义变量数组，送样时间，目前暂定为4，根据实际情况修改
Dim detectTime(4) As String '定义变量数组，检测时间
Dim checker(4) As String '定义变量数组, 检测人员
Dim data_areas As Range
Dim total_data As Integer
Dim current As Integer
Dim over4Names As String '定义一个字符串记录下超过4条记录的用户姓名，在最后输出提示
Dim result As String
Dim n As Long '用来循环遍历
Dim nameArray As Variant '定义一个可变数组将检测表姓名列的数据存下来，加快遍历速度
Set data_areas = Application.InputBox(prompt:="请鼠标选择需要输出数据的区域", Title:="选择", Type:=8) '选取输出的数据区域
i = data_areas.Row '获取选取区域开始行所在行号
j = data_areas.Rows.Count ' 获取选取区域总行数
over4Names = ""
'如果希望不弹框选择文件和存放目录可以将下面三行前面的单引号去除，再将下面一段弹框选择文件的代码删除
'strTemplates = "C:\Users\80668\Desktop\template.docx"
'strData = "C:\Users\80668\data.xlsx"
'Path = "C:\Users\80668\Desktop\报告20210113"
'下面的一段代码是弹出3次框，分别选择模板文件doc，检测数据文件excel，报告存放目录
With Application.FileDialog(msoFileDialogFilePicker) '选择word模板文件
.Filters.Add "word文件", "*.doc*", 1
.AllowMultiSelect = False
If .Show Then strTemplates = .SelectedItems(1) Else Exit Sub
End With
With Application.FileDialog(msoFileDialogFilePicker) '选择excel文件
.Filters.Add "word文件", "*.xls*", 1
.AllowMultiSelect = False
If .Show Then strData = .SelectedItems(1) Else Exit Sub
End With
With Application.FileDialog(msoFileDialogFolderPicker) '获取输出的文件存储路径
If .Show = False Then Exit Sub
Path = .SelectedItems(1)
End With
' 忽略告警加快速度
With Application
.DisplayAlerts = False
.ScreenUpdating = False
End With
Set objApp = CreateObject("Word.Application")
objApp.Visible = False
Set xlApp = CreateObject("Excel.Application")
Set xlBook = xlApp.Workbooks.Open(strData)
xlApp.Visible = False
'下面去检测记录文件的第一个Sheet，可以通过名字取对应的sheet，例如xlBook.Worksheets("Sheet1")
Set xlSheet = xlBook.Worksheets(1)
' 将检测表第2列的姓名数据全部取出来放到数组里面，遍历数组速度比遍历xlSheet速度要快很多
nameArray = xlSheet.Range("B1:B" & xlSheet.Cells(Rows.Count, "B").End(xlUp).Row).Value
' 开始遍历选择的姓名和身份证
For k = i To i + j - 1
userName = Cells(k, 1) '取第一列的姓名
idno = Cells(k, 2) '取第二列的身份证
sampleNo = "" '清空编号
sex = "男" '性别默认为男
current = 0 '初始化为0，用于检测时间数组的数据填充
'清空送样时间、检测时间、检测人员数组，防止数据错乱
For h = 1 To 4
takeTime(h) = ""
detectTime(h) = ""
checker(h) = ""
Next
'如果身份证号码第17位是偶数将性别修改为女性
If Val(Mid(idno, 17, 1)) Mod 2 = 0 Then sex = "女"
'遍历检测记录姓名数组，根据用户姓名匹配所有的检测记录, UBound(nameArray, 1)取姓名数组的最大行号
'第一版程序遍历excel比较姓名是否一致：For n = 3 To xlSheet.UsedRange.Rows.Count If xlSheet.Cells(n, 2) = patientName Then
'第一版程序直接遍历excel的速度非常慢，2分钟才出一份报告，改为数组遍历以后2分钟可以出50份报告了
For n = 2 To UBound(nameArray, 1)
If nameArray(n, 1) = userName Then
If Len(sampleNo) = 0 Then sampleNo = xlSheet.Cells(n, 1)
current = current + 1
If current < 5 Then
takeTime(current) = xlSheet.Cells(n, 4)
detectTime(current) = xlSheet.Cells(n, 5)
checker(current) = xlSheet.Cells(n, 12)
ElseIf current = 5 Then
over4Names = over4Names & "," & userName
End If
End If
Next
Set objDoc = objApp.Documents.Open(strTemplates, , False)
strFileName = userName & ".docx"
'文件名必须包括“.doc”的文件扩展名，如没有则自动加上
If Not strFileName Like "*.docx" Then strFileName = strFileName & ".docx"
'如果文件已存在，则删除已有文件
If Dir(strFileName) "" Then Kill strFileName
'打开模板文件
'开始替换模板预置变量文本
With objApp.Application.Selection
.Find.ClearFormatting
.Find.Replacement.ClearFormatting
With .Find
.Text = "{$姓名}"
.Replacement.Text = userName
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$性别}"
.Replacement.Text = sex
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$身份证}"
.Replacement.Text = idno
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$编号}"
.Replacement.Text = sampleNo
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$年}"
.Replacement.Text = Year(Now)
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$月}"
.Replacement.Text = Month(Now)
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$日}"
.Replacement.Text = Day(Now)
End With
.Find.Execute Replace:=wdReplaceAll
' 循环次数根据实际情况修改，demo是4条记录所以为4
For m = 1 To 4
With .Find
.Text = "{$送样时间" & m & "}"
.Replacement.Text = takeTime(m)
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$检测时间" & m & "}"
.Replacement.Text = detectTime(m)
End With
.Find.Execute Replace:=wdReplaceAll
With .Find
.Text = "{$检测人" & m & "}"
.Replacement.Text = checker(m)
End With
.Find.Execute Replace:=wdReplaceAll
Next
End With
'将写入数据的模板另存为文档文件
objDoc.SaveAs Path & "\" & strFileName
objDoc.Saved = True
objDoc.Close
Next
'将先前的忽略告警恢复为true
With Application
.DisplayAlerts = True
.ScreenUpdating = True
End With
result = "报告生成完毕！"
If Len(over4Names) > 0 Then result = result & "注意下面人员超过了4次检测记录：" & over4Names
MsgBox result, vbYes + vbExclamation
Exit_cmdExportToWord_Click:
Set objApp = Nothing
Set objDoc = Nothing
Set objTable = Nothing
Set xlApp = Nothing
Set xlBook = Nothing
Set xlSheet = Nothing
Exit Sub
Err_cmdExportToWord_Click:
MsgBox Err.Description, vbCritical, "出错"
Resume Exit_cmdExportToWord_Click
End Sub
报告生成操作步骤
先将需要出报告的用户信息粘贴到"报告工具.xlsm"点击生成报告按钮，注意如果有提示需要启用安全内容，否则无法运行VBA弹出一个框，选择需要生成报告用户的区域，然后点击确认弹出文件选择框，选中模板文件template.docx弹出文件选择框，选中检测记录文件data.xlsx弹出文件夹选择框，选中需要报告存放的目录，例如目录"报告20210103"等待程序运行，如果有word提示的弹框"xxx文件被锁定，无法编辑"，点击"只打开副本"，目前每生成一个word需要点击一次如果提示word的模板文件被锁定无法编辑的情况下，建议将原模板doc文件复制出来，使用新复制的doc模板文件来生成报告就不会有弹框的情况，不用每生成一个word点击一次
生成报告结果
报告20210113/张三.docx 
报告20210113/李四.docx 
存在的问题和待改进
每次运行程序以后会弹出一个小框，需要点击’打开只读副本’以后才会继续生成word文件, 这种情况需要复制一个新的模板word文件，使用新的文件生成报告才不会有提示了vba代码格式比较乱检测记录的模板中行数是固定的，demo中默认是4条，无法做到自动根据实际检测数伸缩
参考文章
官网打开word 先保存到数组里面再遍历优化匹配速度
|